module HplAssets.Hephaestus.MetaProgramming where

import Language.Haskell.Syntax
import Data.Generics

-- ----------------------------------------------------------
-- Operators for Haskell program transformation
-- ----------------------------------------------------------

setModuleName :: String -> HsModule -> HsModule
setModuleName n 
              (HsModule _ (Module _) exportSpec importDecls decls) =	 
               HsModule noSrcLoc (Module n) exportSpec importDecls decls


addImportDecl :: String -> HsModule -> HsModule
addImportDecl n 
              (HsModule _ m exportSpec importDecls decls) =	 
               HsModule noSrcLoc m exportSpec importDecls' decls
 where
  importDecls' = importDecls ++
    [ HsImportDecl {
        importLoc = noSrcLoc,
        importModule = Module n, 
        importQualified = False,
        importAs = Nothing, 
        importSpecs = Nothing } ]


addField :: String -> String -> String -> HsModule -> HsModule
addField dataName fieldName typeName
         (HsModule _ m exportSpec importDecls decls) = 
          HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1,decl,decls2) = findDataDecl dataName decls
  fieldType = HsUnBangedTy (HsTyCon (UnQual (HsIdent typeName)))
  decl' = case decl of
            (HsDataDecl _ [] n [] [HsRecDecl _ n' fields] dis) ->
             let fields' = fields ++ [([HsIdent fieldName], fieldType)] in
              HsDataDecl noSrcLoc [] n [] [HsRecDecl noSrcLoc n' fields'] dis
            _ -> error ("Datatype " ++ dataName ++ " not suitable.")


initializeFieldWithFun :: String -> String -> String ->  String -> HsModule -> HsModule
initializeFieldWithFun dataName fieldName parmFun funName = everywhere (mkT initializeField')
 where
  initializeField' :: HsExp -> HsExp
  initializeField' (HsRecConstr (UnQual (HsIdent n)) updates) | n == dataName =
                    HsRecConstr (UnQual (HsIdent n)) updates'
   where
    updates' = updates ++ [ HsFieldUpdate
                              (UnQual (HsIdent fieldName))
                              (HsApp (HsVar (UnQual (HsIdent funName))) (HsParen (HsApp (HsVar (UnQual (HsIdent parmFun))) (HsVar (UnQual (HsIdent "spl"))))))]
  initializeField' x = x


initializeField :: String -> String -> String -> HsModule -> HsModule
initializeField dataName fieldName value= everywhere (mkT initializeField')
 where
  initializeField' :: HsExp -> HsExp
  initializeField' (HsRecConstr (UnQual (HsIdent n)) updates) | n == dataName =
                    HsRecConstr (UnQual (HsIdent n)) updates'
   where
    updates' = updates ++ [ HsFieldUpdate
                              (UnQual (HsIdent fieldName))
                              (HsVar (UnQual (HsIdent value))) ]
  initializeField' x = x

--
-- This is a very specific (restricted) kind of constructor addition.
--
addConstructor :: String -> String -> HsModule -> HsModule
addConstructor dataName typeName 
               (HsModule _ m exportSpec importDecls decls) = 
                HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1,decl,decls2) = findDataDecl dataName decls
  componentType = HsUnBangedTy (HsTyCon (UnQual (HsIdent typeName)))
  decl' = case decl of
            (HsDataDecl _ [] n [] conDecls []) ->
             let conDecls' = conDecls ++ [HsConDecl noSrcLoc (HsIdent typeName) [componentType]] in
              HsDataDecl noSrcLoc [] n [] conDecls' []
            _ -> error ("Datatype " ++ dataName ++ " not suitable.")


--
-- Similar to addConstructor, but includes a new constructor without arguments. Used in the data type ExportModel 
--
addConstructor2 :: String -> String -> HsModule -> HsModule
addConstructor2 dataName typeName 
               (HsModule _ m exportSpec importDecls decls) = 
                HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1,decl,decls2) = findDataDecl dataName decls
  decl' = case decl of
            (HsDataDecl _ [] n [] conDecls []) ->
             let conDecls' = conDecls ++ [HsConDecl noSrcLoc (HsIdent typeName) []] in
              HsDataDecl noSrcLoc [] n [] conDecls' []
            _ -> error ("Datatype " ++ dataName ++ " not suitable.")



--
-- This is a very specific (restricted) kind of constructor addition.
-- Created by Lucineia to build data type ExportModel
addConstructorWithoutArgs :: String -> String -> HsModule -> HsModule
addConstructorWithoutArgs dataName typeName 
               (HsModule _ m exportSpec importDecls decls) = 
                HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1,decl,decls2) = findDataDecl dataName decls
  decl' = case decl of
            (HsDataDecl _ [] n [] conDecls []) ->
             let conDecls' = conDecls ++ [HsConDecl noSrcLoc (HsIdent typeName) []] in
              HsDataDecl noSrcLoc [] n [] conDecls' []
            _ -> error ("Datatype " ++ dataName ++ " not suitable.")


--
-- Please note that this operation makes rich assumptions.
--
addUpdateCase :: String -> String -> String -> [String] -> String -> HsModule -> HsModule
addUpdateCase funName funName' con argFuns sel
              (HsModule _ m exportSpec importDecls decls) = 
               HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1, HsFunBind cases, decls2) = findFunBind funName decls
  decl' = HsFunBind (cases ++ [HsMatch noSrcLoc (HsIdent funName) (pat1:vpats) rhs []])
  var1 = HsIdent "x0"
  pat1 = HsPApp (UnQual (HsIdent con)) [HsPVar var1]
  argFuns' = map (HsVar . UnQual . HsIdent) (argFuns ++ [sel])
  vars = map (HsIdent . (++) "x" . show) [1..length argFuns']
  vexps = map (HsVar . UnQual) vars
  vpats = map HsPVar vars 
  -- source code of Ralf
  --rhs = HsUnGuardedRhs (update (foldl apply fun' (zip vexps argFuns')))
  --fun' = HsApp (HsVar (UnQual (HsIdent funName'))) (HsVar (UnQual var1)) 
  --apply e (v,f) = HsApp e (HsParen (HsApp f v))
  --update r = HsRecUpdate (last vexps) [HsFieldUpdate (UnQual (HsIdent sel)) r]
  
  -- new code to send the same parameters to transformation function of the asset, i.e., SPLModel->InstanceModel->InstanceModel
  vars3 = map ((++) " x" . show) [0..length argFuns']  
  rhs = HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent funName'))) (HsVar (UnQual (HsIdent (concat vars3)))))
  
--
-- This operation is used to extend export function.
--
addUpdateCase2 :: String -> String -> String -> String  -> String -> HsModule -> HsModule
addUpdateCase2 funName funName' con extFile sel
              (HsModule _ m exportSpec importDecls decls) = 
               HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1, HsFunBind cases, decls2) = findFunBind funName decls
  decl' = HsFunBind (cases ++ [HsMatch noSrcLoc (HsIdent funName) (pat1:vpats) rhs []])
  pat1 = HsPApp (UnQual (HsIdent con)) []
  vars = map (HsIdent . (++) "x" . show) [1,2]
  vpats = map HsPVar vars 
  rhs = HsUnGuardedRhs (HsApp (HsApp (HsVar (UnQual (HsIdent funName'))) 
         (HsParen (HsInfixApp (HsVar (UnQual (HsIdent "x1"))) (HsQVarOp (UnQual (HsSymbol "++"))) (HsLit (HsString extFile))))) 
         (HsParen (HsApp (HsVar (UnQual (HsIdent sel))) (HsVar (UnQual (HsIdent "x2"))))))


--
-- Please note that this operation makes rich assumptions.
--

addUpdateCaseParserCK :: String -> String -> String -> String -> String -> String -> String -> HsModule -> HsModule
addUpdateCaseParserCK funName typeTransf stTran dtTran peTran pDtTran condFunc
              (HsModule _ m exportSpec importDecls decls) = 
               HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1, HsFunBind cases, decls2) = findFunBind funName decls
  decl' = HsFunBind (cases ++ [HsMatch noSrcLoc (HsIdent funName) pat1 rhs []])
  pat1 = [HsPLit (HsString stTran), HsPVar (HsIdent peTran)]
  rhs = case condFunc of
	     "Success" -> HsUnGuardedRhs (HsApp (HsCon (UnQual (HsIdent condFunc))) (HsParen (HsApp (HsCon (UnQual (HsIdent typeTransf))) 
                       (HsParen (HsApp (HsCon (UnQual (HsIdent dtTran))) (HsVar (UnQual (HsIdent pDtTran))))))))
             otherwise -> HsUnGuardedRhs (HsApp (HsCon (UnQual (HsIdent condFunc))) (HsLit (HsString ("Invalid number of arguments to the transformation " ++ stTran))))
                       

--
-- Please note that this operation makes rich assumptions.
-- Created by Lucineia to build function export
addUpdateCaseWithoutArgs :: String -> String -> String -> [String] -> String -> HsModule -> HsModule
addUpdateCaseWithoutArgs funName funName' con argFuns sel
              (HsModule _ m exportSpec importDecls decls) = 
               HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
 where
  (decls1, HsFunBind cases, decls2) = findFunBind funName decls
  decl' = HsFunBind (cases ++ [HsMatch noSrcLoc (HsIdent funName) (pat1:vpats) rhs []])
  pat1 = HsPApp (UnQual (HsIdent con)) []
  argFuns' = map (HsVar . UnQual . HsIdent) (argFuns ++ [sel])
  vars = map (HsIdent . (++) "x" . show) [1..length argFuns']
  vexps = map (HsVar . UnQual) vars
  vpats = map HsPVar vars 
  vars3 = map ((++) " x" . show) [1..length argFuns']  
  rhs = HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent funName'))) (HsVar (UnQual (HsIdent (concat vars3)))))


addConstructorList :: String -> [String] -> HsModule -> HsModule
addConstructorList dataName [typeName]    = addConstructorWithoutArgs dataName typeName
addConstructorList dataName (typeName:xs) = addConstructorWithoutArgs dataName typeName . addConstructorList dataName xs


addUpdateCaseList :: String -> [String] -> [String] -> [String] -> String -> HsModule -> HsModule
addUpdateCaseList funName [funName'] [con] argFuns sel       = addUpdateCaseWithoutArgs funName funName' con argFuns sel
addUpdateCaseList funName (funName':xs) (con:ys) argFuns sel = addUpdateCaseWithoutArgs funName funName' con argFuns sel . addUpdateCaseList funName xs ys argFuns sel

addElemListWithList :: String -> [String] -> HsModule -> HsModule
addElemListWithList dataName [fieldName]    =  addElemList dataName fieldName 
addElemListWithList dataName (fieldName:xs) =  addElemList dataName fieldName . addElemListWithList dataName xs 


-- 
-- add a new element in a list. Used to lists "lstExport" and "lstComandsMain" 
-- Created by Lucineia in November 20th, 2011
addElemList :: String -> String -> HsModule -> HsModule
addElemList dataName fieldName 
         (HsModule _ m exportSpec importDecls decls) = 
          HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
  where
  (decls1,decl,decls2) = findData dataName decls
  decl' = case decl of
            (HsPatBind _ n (HsUnGuardedRhs (HsList lst)) decls3) ->
	      let rhs' = (HsUnGuardedRhs (HsList (lst ++ [HsCon (UnQual (HsIdent fieldName))]))) in 
	          HsPatBind noSrcLoc n rhs' decls3
--             _ -> error ("Datatype " ++ dataName ++ " not suitable.")


-- Below we present three functions created to insert statements in the function "main" of the Hephaestus product.
-- They are the type of HsStmt instructins: HsLetStmt, HsGenerator and HsQualifier
-- They are used to insert statements about findPropertyValue, Parsers and Exports of assets 

--addInstructionLet "main" "findPropertyValue" "target-dir" "u" "usecase-model"
addInstructionLet:: String -> String -> String -> String ->  String -> HsModule -> HsModule
addInstructionLet nameFunc p1 p2 name1 name2 
           (HsModule _ m exportSpec importDecls decls) = 
            HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
  where
  (decls1,decl,decls2) = findData nameFunc decls
  decl' = case decl of
	       (HsPatBind _ n (HsUnGuardedRhs (HsDo lstStmt)) lstdecl) -> 
--	        let (lstStmt1, stmt, lstStmt2) = find p1 p2 lstStmt in (HsPatBind noSrcLoc n (HsUnGuardedRhs (HsDo ((lstStmt1:([stmt] ++ [HsLetStmt [HsPatBind noSrcLoc (HsPVar (HsIdent name1)) (HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent "fromJust"))) (HsParen (HsApp (HsApp (HsVar (UnQual (HsIdent p1))) (HsLit (HsString name2))) (HsVar (UnQual (HsIdent "ps"))))))) []]])):lstStmt2))) lstdecl ))
	        let {(lstStmt1, stmt, lstStmt2) = findStmtLet p1 p2 lstStmt ;
		  stmt'= [stmt] ++ [HsLetStmt [HsPatBind noSrcLoc (HsPVar (HsIdent name1)) (HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent "fromJust"))) (HsParen (HsApp (HsApp (HsVar (UnQual (HsIdent p1))) (HsLit (HsString name2))) (HsVar (UnQual (HsIdent "ps"))))))) []]] } in 
		   (HsPatBind noSrcLoc n (HsUnGuardedRhs (HsDo (lstStmt1++stmt'++lstStmt2))) lstdecl )
	        
	        
--search: imp <- parseInstanceModel (ns fcSchema) (snd i) 
--insert: ucp <- parseUseCaseFile (ns ucSchema) (snd u) , for example
--addInstructionGenerator "main" "parseInstanceModel" "ucp" parseUseCaseFile" "ucSchema" "u"
addInstructionGenerator:: String -> String -> String -> String -> String -> String -> HsModule -> HsModule
addInstructionGenerator nameFunc fParseFind varParseNew fParseNew schemaParseNew varPropertyNew 
           (HsModule _ m exportSpec importDecls decls) = 
            HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
  where
  (decls1,decl,decls2) = findData nameFunc decls
  decl' = case decl of
	       (HsPatBind _ n (HsUnGuardedRhs (HsDo lstStmt)) lstdecl) -> 
--	        let (lstStmt1, stmt, lstStmt2) = find p1 p2 lstStmt in (HsPatBind noSrcLoc n (HsUnGuardedRhs (HsDo ((lstStmt1:([stmt] ++ [HsLetStmt [HsPatBind noSrcLoc (HsPVar (HsIdent name1)) (HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent "fromJust"))) (HsParen (HsApp (HsApp (HsVar (UnQual (HsIdent p1))) (HsLit (HsString name2))) (HsVar (UnQual (HsIdent "ps"))))))) []]])):lstStmt2))) lstdecl ))
	        let {(lstStmt1, stmt, lstStmt2) = findStmtParse fParseFind lstStmt ;
		      stmt'=  [stmt] ++ [HsGenerator noSrcLoc (HsPVar (HsIdent ("(Core.Success "++varParseNew++")"))) (HsApp (HsApp (HsVar (UnQual (HsIdent fParseNew))) 
                                  (HsParen (HsApp (HsVar (UnQual (HsIdent "ns"))) (HsVar (UnQual (HsIdent schemaParseNew)))))) 
                                  (HsParen (HsApp (HsVar (UnQual (HsIdent "snd"))) (HsVar (UnQual (HsIdent varPropertyNew))))))] } in 
		      (HsPatBind noSrcLoc n (HsUnGuardedRhs (HsDo (lstStmt1++stmt'++lstStmt2))) lstdecl )
	        
	
-- insert statement for example "exportUcmToLatex out (ucm product)"
addInstructionQualifier:: String -> String -> String -> String -> String -> HsModule -> HsModule
addInstructionQualifier nameFunc varFind pathFile funNew sel 
           (HsModule _ m exportSpec importDecls decls) = 
            HsModule noSrcLoc m exportSpec importDecls (decls1 ++ [decl'] ++ decls2)
  where
  (decls1,decl,decls2) = findData nameFunc decls
  decl' = case decl of
	       (HsPatBind _ n (HsUnGuardedRhs (HsDo lstStmt)) lstdecl) -> 
--	        let (lstStmt1, stmt, lstStmt2) = find p1 p2 lstStmt in (HsPatBind noSrcLoc n (HsUnGuardedRhs (HsDo ((lstStmt1:([stmt] ++ [HsLetStmt [HsPatBind noSrcLoc (HsPVar (HsIdent name1)) (HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent "fromJust"))) (HsParen (HsApp (HsApp (HsVar (UnQual (HsIdent p1))) (HsLit (HsString name2))) (HsVar (UnQual (HsIdent "ps"))))))) []]])):lstStmt2))) lstdecl ))
	        let {(lstStmt1, stmt, lstStmt2) = findStmtLet' varFind lstStmt ;
		      stmt'=  [stmt] ++ [HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent funNew))) (HsVar (UnQual (HsIdent pathFile)))) 
						      (HsParen (HsApp (HsVar (UnQual (HsIdent sel))) (HsVar (UnQual (HsIdent "product"))))))] } in 
		      (HsPatBind noSrcLoc n (HsUnGuardedRhs (HsDo (lstStmt1++stmt'++lstStmt2))) lstdecl )


-- ----------------------------------------------------------
-- Utilities for the transformations
-- ----------------------------------------------------------
findDataDecl :: String -> [HsDecl] -> ([HsDecl], HsDecl, [HsDecl])
findDataDecl n decls = findDataDecl' [] decls 
 where
  findDataDecl' _ [] = error ("Datatype " ++ n ++ " not found.")
  findDataDecl' decls1 (decl@(HsDataDecl _ _ n' _ _ _):decls2)
    = if HsIdent n == n'
        then (decls1,decl,decls2)
        else findDataDecl' (decls1 ++ [decl]) decls2
  findDataDecl' decls1 (decl:decls2)
    = findDataDecl' (decls1 ++ [decl]) decls2


findFunBind :: String -> [HsDecl] -> ([HsDecl], HsDecl, [HsDecl])
findFunBind n decls = findFunBind' [] decls 
 where
  findFunBind' _ [] = error ("Function " ++ n ++ " not found.")
  findFunBind' decls1 (decl@(HsFunBind ((HsMatch _ n' _ _ _):_)):decls2)
    = if HsIdent n == n'
        then (decls1,decl,decls2)
        else findFunBind' (decls1 ++ [decl]) decls2
  findFunBind' decls1 (decl:decls2)
    = findFunBind' (decls1 ++ [decl]) decls2
    

-- Created by Lucineia in November 20th, 2011  
-- HsPatBind noSrcLoc (HsPVar (HsIdent dataName)) rhs' [HsDecl]
findData :: String -> [HsDecl] -> ([HsDecl], HsDecl, [HsDecl])
findData n decls = findData' [] decls 
 where
  findData' _ [] = error ("Datatype " ++ n ++ " not found.")
  findData' decls1 (decl@(HsPatBind _ n' _ _ ):decls2)
    = if (HsPVar (HsIdent n)) == n'
        then (decls1,decl,decls2)
        else findData' (decls1 ++ [decl]) decls2
  findData' decls1 (decl:decls2)
    = findData' (decls1 ++ [decl]) decls2


--find "findPropertyValue" "target-dir"
findStmtLet :: String -> String -> [HsStmt] -> ([HsStmt], HsStmt, [HsStmt])
findStmtLet funcStmt parmStmt stmts = find' [] stmts 
 where
  find' _ [] = error ("Command Let " ++ funcStmt ++ parmStmt ++ " not found.")
  find' stmts1 (stmt@(HsLetStmt [HsPatBind _ _ p1' _ ]):stmts2)
    = if (HsUnGuardedRhs (HsApp (HsVar (UnQual (HsIdent "fromJust"))) 
           (HsParen (HsApp (HsApp (HsVar (UnQual (HsIdent funcStmt))) 
             (HsLit (HsString parmStmt))) (HsVar (UnQual (HsIdent "ps"))))))) == p1'
        then (stmts1,stmt,stmts2)
        else find' (stmts1 ++ [stmt]) stmts2
  find' stmts1 (stmt:stmts2)
    = find' (stmts1 ++ [stmt]) stmts2
    

--find the begin of statement LET, for example, "let out = ..."
findStmtLet' :: String -> [HsStmt] -> ([HsStmt], HsStmt, [HsStmt])
findStmtLet' varStmtLet stmts = find' [] stmts 
 where
  find' _ [] = error ("Command Let " ++ varStmtLet ++ " not found.")
  find' stmts1 (stmt@(HsLetStmt [HsPatBind _ p1' _ _ ]):stmts2)
    = if (HsPVar (HsIdent varStmtLet)) == p1'
        then (stmts1,stmt,stmts2)
        else find' (stmts1 ++ [stmt]) stmts2
  find' stmts1 (stmt:stmts2)
    = find' (stmts1 ++ [stmt]) stmts2

    

--findStmt to find the sentences: 
--let t = fromJust (findPropertyValue "target-dir" ps)
--imp <- parseInstanceModel (ns fcSchema) (snd i)  
findStmtParse :: String -> [HsStmt] -> ([HsStmt], HsStmt, [HsStmt])
findStmtParse parmStmt stmts = find' [] stmts 
 where
  find' _ [] = error ("Command " ++ parmStmt ++ " not found.")
  find' stmts1 (stmt@(HsGenerator _ _ (HsApp (HsApp p1' _ ) _ )):stmts2)
    = if (HsVar (UnQual (HsIdent parmStmt))) == p1'
        then (stmts1,stmt,stmts2)
        else find' (stmts1 ++ [stmt]) stmts2
  find' stmts1 (stmt:stmts2)
    = find' (stmts1 ++ [stmt]) stmts2  

  

noSrcLoc :: SrcLoc
noSrcLoc = undefined

undefinedRhs :: HsRhs
undefinedRhs = HsUnGuardedRhs (HsVar (UnQual (HsIdent "undefined")))
